home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Toolbox classes / View < prev    next >
Text File  |  1993-02-25  |  13KB  |  366 lines
  1. \ VIEW class.
  2. \ Oct 91    mrh    Initial version.
  3. \ May 92    mrh    Support for "new-style" controls
  4. \ Feb 93    mrh    Added IDLE: method
  5.  
  6. \ VIEW is the generic superclass for everything that can be drawn in a
  7. \ window.  For example, all controls are now drawn in a view, rather than
  8. \ in a window as such, although every view must have an owning window.
  9. \ This idea is lifted from MacApp and TCL, except that in Mops a Window
  10. \ itself isn't a view, but contains one special view (the ContView) which
  11. \ covers the whole drawing area of the window (excluding any scroll bars).
  12.  
  13. \ In the view, we have an ivar which is a rect, ViewRect.  This is the
  14. \ rectangle defining the outer boundary of this view, relative to the
  15. \ current grafPort.  This rect is used by its owning view to set the clip
  16. \ region and the coordinate origin before calling any method on the view.
  17.  
  18. need    ctl
  19.  
  20. \ Here we define the modes for subview corner points when the superview
  21. \ is resized.  So far we have Anchored, which means the point stays the
  22. \ same distance from the corresponding superview point, Proportional,
  23. \ which means the point stays proportionately at the same position along
  24. \ the superview's edge, and Floating, which means that the subview edge
  25. \ stays the same length, and this point has its position dictated by what
  26. \ its "partner" does.  If both are Floating, then the centre point of the
  27. \ edge will stay in the same proportional position.
  28.  
  29. type{ anchored  proportional  floating }
  30.  
  31.     0    value    MPOINT
  32.  
  33. \ Utility words
  34.  
  35. : NOCLIP    0 0 32766 dup  put: tempRect  addr: tempRect  call ClipRect  ;
  36.  
  37. : CTLEXEC        \ ( part# ctlHndl -- )  Executes action for control.
  38.      get-ctl-obj  exec: **  ;
  39.  
  40. \ CtlProc is the procedure to be executed when a control is being tracked.
  41.  
  42. :proc CTLPROC        \  ( ctlHndl int:part -- )
  43.     word0 swap  ctlExec  ;proc
  44.  
  45. \ CTLHIT? looks for a control click.
  46.  
  47. : CTLHIT?  { wind \ part ^ctl action1 action2 -- b }
  48.     where: fEvent  g->l  -> mpoint        \ save mouse loc
  49.     word0 mpoint wind theCtl  call FindControl
  50.     word0 -> part
  51.     theCtl @  -> ^ctl                    \ ctl handle
  52.     part
  53.     CASE[ inThumb ], [ inCheckBox ], [ inButton ]=>
  54.                                         \ Only exec after mouseUp
  55.         0 ->  action1                    \ 0 since gets passed to TrackControl
  56.         ['] ctlExec  -> action2
  57.     DEFAULT=>
  58.         drop  ['] ctlproc -> action1  ['] 2drop -> action2
  59.     ]CASE
  60.     ^ctl
  61.     IF    word0  ^ctl  mpoint  action1  call TrackControl  word0
  62.         ^ctl  action2 execute  true
  63.     ELSE    false
  64.     THEN  ;
  65.  
  66.  
  67. \ Class PtrList is used for a list of pointers which needs to be expandable.
  68. \ We will use this to implement a view's list of its subviews, and also
  69. \ its list of controls.  We may eventually migrate it back into Mops.dic if
  70. \ it turns out to be useful enough.  Also we don't have a REMOVE: method
  71. \ yet -- put it in if you need it!
  72.  
  73.  
  74. :class    PTRLIST  super{ string  sequence }
  75.  
  76. :m ADD:        \ ( ptr -- )
  77.     pad !  pad 4  add: super  ;m
  78.  
  79. :m FIRST?:
  80.     size: super  nif  false  exit  then   \ No elements - return false
  81.     reset: super  ^1st: super @  true  ;m
  82.  
  83. :m NEXT?:    \ ( -- ptr T  |  -- F )
  84.     4 skip: super  len: super  NIF  false  exit  THEN
  85.     ^1st: super  @  true  ;m
  86.     
  87. ;class
  88.  
  89.  
  90. \            ==============================
  91.  
  92. :class    VIEW    super{ object }  general
  93.  
  94.     rect        VIEWRECT        \ Bounding rectangle, rel to grafport.
  95.     ptr            ^MyVIEW            \ Points to containing view
  96.     ptr            ^MyWIND            \ Points to owning window
  97.     ptrList        SUBVIEWS        \ List of views that this one contains
  98.     ptrList        CONTROLS        \ List of controls for this view
  99.     x-addr        DRAW            \ Draw handler
  100.     x-addr        ClickHndlr        \ We call this for a click
  101.     bool        ALIVE?
  102.     bool        ENABLED?
  103.     bool        WantsClicks?    \ True if we can accept clicks
  104.     bool        SetClip?        \ True if we need to set the clip (default)
  105.     byte        #updates        \ Counts number of pending updates
  106.     byte        Tmode            \ Modes for 4 corner points - these
  107.     byte        Bmode            \  control the behaviour when
  108.     byte        Lmode            \  the containing view is resized.
  109.     byte        Rmode
  110.  
  111.  
  112. :m GETRECT:        get: viewRect  ;m
  113. :m GET^RECT:    addr: viewRect  ;m
  114. :m ENABLED?:    get: enabled?  ;m
  115. :m WINDOW:        get: ^MyWind  ;m
  116. :m SETWINDOW:    put: ^MyWind  ;m
  117. :m WANTSCLICKS:    put: wantsClicks?  ;m
  118. :m SETCLICK:    put: ClickHndlr  true  put: wantsClicks?  ;m
  119. :m SETDRAW:        put: draw  ;m
  120. :m SETMODES:    put: Bmode  put: Rmode  put: Tmode  put: Lmode  ;m
  121. :m SUPERVIEW:    get: ^MyView  ;m
  122.  
  123. :m INIT:    \ ( left top rt bot -- )  Parms give the bounding rectangle
  124.             \    for the view, relative to the owning view, or relative
  125.             \    to the owning window if this isn't a subview.
  126.     put: viewRect  ;m
  127.  
  128. \ ADDVIEW: adds the passed-in view to this view's list of subviews,
  129. \ and ADDCTL: adds a control to this view's list of controls.  These must
  130. \ be called at run time, since pointers are used, and also they have to be
  131. \ called before NEW:.
  132.  
  133. :m ADDVIEW:    ( ^view -- )    add: subviews  ;m
  134. :m ADDCTL:    ( ^ctl -- )        add: controls  ;m
  135.  
  136.  
  137. \ NEW:  ( ^oview -- )  fires up the view.  ^oView is the owning view if
  138. \ this is a subview, nilP otherwise.  This method in normally called
  139. \ automatically when NEW: is called on the owning window.
  140.  
  141. :m NEW:        \ ( ^oview -- )
  142.     put: ^myView
  143.     nil?: ^myView
  144.     NIF     window: [ get: ^myView ]  put: ^myWind
  145.     THEN
  146.     addr: viewRect  call ClipRect
  147.     BEGIN  ^base   each: controls  WHILE  new: []  REPEAT   drop
  148.     BEGIN  ^base   each: subviews  WHILE  new: []  REPEAT   drop
  149.     noClip  true  put: alive?  ;m
  150.  
  151. :m RELEASE:
  152.     BEGIN   each: subviews  WHILE  release: []  REPEAT
  153.     BEGIN   each: controls  WHILE  release: []  REPEAT
  154.     false  put: alive?   ;m
  155.  
  156. private
  157.  
  158.  
  159. :m (ADJ):  { soStrt soEnd snStrt snEnd myStrt myEnd strtMode endMode
  160.                 \ myLen soLen snLen adj -- myStrt myEnd  }
  161.                 
  162.     soEnd soStrt -    -> soLen
  163.     snEnd snStrt -    -> snLen
  164.     myEnd myStrt -    -> myLen
  165.     
  166.         \ First we handle the pure displacement component, before we
  167.         \ worry about the size change.
  168.         
  169.     snStrt soStrt -  dup  ++> myStrt  ++> myEnd
  170.  
  171.         \ Now we handle the size change, depending on the modes.
  172.         \ First we check for both sides Floating, as this is a special
  173.         \ case.
  174.         
  175.     strtMode  floating =   endMode  floating =  and
  176.     IF    snLen soLen -  2/  dup  ++> myStrt  ++> myEnd
  177.     ELSE
  178.             \ For the other cases, we set myStrt and myEnd as for Anchored
  179.             \ mode, then if either is different, we adjust.
  180.         
  181.         snLen soLen -   -> adj
  182.         adj ++> myEnd
  183.         strtMode  proportional =
  184.         IF    adj  myStrt snStrt -  soLen  */  ++> myStrt    THEN
  185.         endMode  proportional =
  186.         IF    adj  snEnd  myEnd  -  soLen  */  --> myEnd    THEN
  187.         strtMode  floating =
  188.         IF    myEnd  myLen -  -> myStrt    THEN
  189.         endMode  floating =
  190.         IF    myStrt  myLen +  -> myEnd    THEN
  191.     THEN
  192.     myStrt  myEnd  ;m
  193.     
  194. public
  195.  
  196. :m ADJUSTSIZE:  { snL snT snR snB \ myL myT myR myB  soL soT soR soB -- }
  197.  
  198. \ This method adjusts the size of the view, in accordance with a resize
  199. \ of the superview, taking into account the modes Tmode, Bmode etc.
  200. \ We allow a repositioning of the superview to occur as well, as this
  201. \ simplifies things when dealing with subviews containing subviews.
  202. \ snL etc. are the new coordinates of the superview's viewRect.  We assume
  203. \ the old values are still in the viewRect itself.  Here we copy them into
  204. \ soL, soT, soR and soB.  This method is really only public since we late
  205. \ bind to it.
  206.  
  207.     get: viewRect  -> myB  -> myR  -> myT  -> myL    \ My viewRect
  208.     getRect: [ get: ^myView ]  -> soB -> soR -> soT -> soL
  209.                         \ Superview's old viewRect
  210.     soL soR  snL snR myL myR  get: Lmode  get: Rmode  (adj): self
  211.     -> myR  -> myL
  212.     soT soB  snT snB  myT myB  get: Tmode  get: Bmode  (adj): self
  213.     -> myB  -> myT
  214.     begin    myL myT myR myB   each: subviews
  215.     while    adjustSize: []
  216.     repeat   2drop 2drop
  217.     myL myT myR myB  put: viewRect  ;m
  218.  
  219. :m SETRECT: {  left top rt bot -- }
  220.     begin    left top rt bot  each: subviews  while  adjustSize: []
  221.     repeat   2drop 2drop
  222.     left top rt bot   put: viewRect  ;m
  223.  
  224.  
  225. \ (SHIFT): ( dx dy -- ) does the housekeeping for a shift of the view
  226. \ by the given distance.  It adjusts the viewRect and calls (shift):
  227. \ on all the subviews.  I was planning to eventually implement SHIFT:
  228. \ which would actually move the view's screen image as well, but now I
  229. \ think this is covered by the PAN: method of class Scroller.
  230.  
  231. :m (SHIFT): { dx dy \ left top rt bot -- }
  232.             \ Shifts the view the given distance.  Doesn't draw anything.
  233.     get: viewRect  -> bot  -> rt  -> top  -> left
  234.     left dx +   top dy +   rt dx +   bot dy +   put: viewRect
  235.     begin  dx dy  each: subviews  while  (shift): []  repeat  2drop  ;m
  236.  
  237. :m MOVE:  { x y \ oldL oldT newL newT -- }
  238.         \ Moves the view so that its top left corner is at
  239.         \ (x,y) relative to the owning view.  Keeps subviews in their
  240.         \ same relative position.
  241.     getTop: viewRect  -> oldT  -> oldL                \ Where we are now
  242.     getRect: [ get: ^myView ]  2drop
  243.     -> newT  -> newL
  244.     x ++> newL   y ++> newT                            \ Where we're going
  245.     newL oldL -   newT oldT -   (shift): self  ;m
  246.  
  247. \ DRAW: is the method called to get the view to draw itself.  There
  248. \ are a few subtleties.  Before drawing is done, we set the clip region
  249. \ to viewRect, and then set the origin so that the top left corner of
  250. \ viewRect will be (0, 0).  Both MacApp and TCL do the equivalent, so I
  251. \ guess it's a good idea.  Then after drawing, we need to call draw:
  252. \ for all the subviews.  Now here's the good part.  Both these jobs can
  253. \ be done via the CallFirst/CallLast mechanism, so the DRAW: method itself
  254. \ can just do the drawing.  Here in the View class itself, this just
  255. \ consists of executing the draw handler.
  256.  
  257. \ Another useful point: when the draw handler is executed, tempRect will
  258. \ contain the bounding rectangle for the drawing, relative to the current
  259. \ origin.  This can be used to draw a frame, for example.
  260.  
  261. \ Final note: we DON'T clear the drawing area before calling the draw
  262. \ handler.  If you need it cleared, do it in the draw handler.
  263.  
  264. private
  265.  
  266. :m SetTempRect:  { \ left top rt bot -- }
  267.         \ Sets tempRect to a view-relative version of viewRect
  268.         \ -- we use this for a number of things.
  269.     get: viewRect  -> bot  -> rt  -> top  -> left
  270.     0  0  rt left -  bot top -  put: tempRect  ;m
  271.  
  272. public
  273.  
  274. \ SETCLIP: sets the clip before drawing.  This is a rather elaborate
  275. \ process, since we need to set the clip to the intersection of this
  276. \ view's viewRect and all its superviews' viewRects (which could possibly
  277. \ be smaller).  This can all be inhibited by setting SetClip? false
  278. \ (which we do when scrolling, for example, since the system has kindly
  279. \ set the clip for us already).
  280.  
  281. \ Note: when this method is called, the origin has been set so that the
  282. \ top left of this view is (0,0).  This is because we're going to use
  283. \ this origin for the drawing, and unless we use the same when we set the
  284. \ clip, the clip rectangle gets translated away somewhere strange!
  285.  
  286. \ This method has to be public since we late-bind to it.
  287.  
  288. :m SetClip: { \ ^view oLeft oTop left top rt bot -- }
  289.                                     \  Note: origin is rel to this view.
  290.     get: setClip?  nif  true put: setClip?  exit  then
  291.     get: viewRect  -> bot  -> rt  -> top  -> left
  292.     left -> oLeft  top -> oTop        \ For origin adjustment later
  293.     get: ^myView -> ^view
  294.     BEGIN    ^view nilP <>
  295.     WHILE    ^view  getRect: view    \ Slight kludge to ensure we get 
  296.                                     \   the viewRect itself, excluding
  297.                                     \   any scroll bars.
  298.         bot min -> bot  rt min -> rt  top max -> top  left max -> left
  299.         ^view superView: view  -> ^view
  300.     REPEAT
  301.     left oLeft -  top oTop -  rt oLeft -  bot oTop -  put: tempRect
  302.     addr: tempRect  call ClipRect  ;m
  303.  
  304. private
  305.  
  306. :m SetupDraw:  { \ left top rt bot -- }
  307.     get: ^myWind  set: window    \ Make sure we draw in the right window!
  308.     0  call SetOrigin
  309.     get: viewRect   -> bot  -> rt  -> top  -> left
  310.     left negate top negate   pack  call SetOrigin
  311.     get: setClip?
  312.     IF  setClip: [self]  else  true put: setClip?  THEN
  313.     setTempRect: self  ;m
  314.  
  315. :m WindupDraw:
  316.     BEGIN  each: controls  WHILE  draw: []  REPEAT
  317.     BEGIN  each: subviews  WHILE  draw: []  REPEAT
  318.     0   call SetOrigin
  319.     0 put: #updates   noClip  ;m
  320.     
  321. public
  322.  
  323. callFirst    setupDraw:
  324. callLast    windupDraw:
  325.  
  326. :m DRAW:        exec: draw  ;m
  327.  
  328.  
  329. :m IDLE:    \ Can be used in subview to call TEidle or whatever.
  330.     BEGIN  each: subviews  WHILE  idle: **  REPEAT  ;m 
  331.  
  332.  
  333. :m CLICK:    \ ( -- b )   Returns true if we've handled the click.
  334.     get: wantsClicks?  NIF  false  EXIT  THEN
  335.     BEGIN    each: subviews
  336.     WHILE    click: **  IF  uneach: subviews  true  EXIT  THEN
  337.     REPEAT
  338.             \ OK, the click wasn't in any of my subviews, but was it
  339.             \ in my own area?
  340.     0  where: fEvent  g->l  addr: viewRect  call PtInRect
  341.     IF        exec: clickHndlr  true
  342.     ELSE    false
  343.     THEN   ;m
  344.  
  345.  
  346. :m KEY:        \ ( c -- )
  347.     BEGIN  dup  each: subviews  WHILE  key: **  REPEAT  drop  ;m
  348.  
  349.  
  350. :m ENABLE:
  351.     true put: enabled?
  352.     BEGIN  each: subviews  WHILE  enable: **  REPEAT  ;m 
  353.  
  354. :m DISABLE:
  355.     false put: enabled?
  356.     BEGIN  each: subviews  WHILE  disable: **  REPEAT  ;m
  357.  
  358.  
  359. :m CLASSINIT:    
  360.     true put: wantsClicks?  true put: setClip?
  361.     proportional  dup 2dup  setModes: self   ;m
  362.  
  363. ;class
  364.  
  365. endload
  366.